home *** CD-ROM | disk | FTP | other *** search
/ The Best of MacTutor - S…e Code for Volumes 1 to 5 / The Best of MacTutor - Source Code for Volume 1-5 (Wayzata Technology)(6031)(1990).bin / Source Code / #27 (Dec 87) / fortran dialogs / whizbang.for < prev    next >
Text File  |  1987-08-26  |  5KB  |  192 lines
  1.     PROGRAM WHIZBANG
  2.  
  3.     implicit none
  4.  
  5.     integer aDefItem
  6.     parameter ( aDefItem = Z'A8' )
  7.  
  8.     integer ctlprc , my_filter , filter_1 , my_filter_ptr
  9.     external ctlprc , my_filter
  10.     
  11.     integer get_dit , result , dialog_ptr , toolbx
  12.     
  13.     integer top_field , bottom_field , result_field , end_dialog
  14.     parameter ( top_field =        1 )
  15.     parameter ( bottom_field =    2 )
  16.     parameter ( result_field =    3 )
  17.     parameter ( end_dialog =    4 )
  18.     
  19.     integer TEINIT
  20.     parameter (TEINIT=Z'9CC00000')
  21.     integer GETNEWDIALOG,DISPOSDIALOG,INITDIALOGS
  22.     integer MODALDIALOG
  23.     parameter (GETNEWDIALOG=Z'97C8A400',
  24.      +    DISPOSDIALOG=Z'98310000',MODALDIALOG=Z'99116000')
  25.     parameter (INITDIALOGS=Z'97B10000')
  26.     INTEGER HIDEWINDOW
  27.     PARAMETER (HIDEWINDOW=Z'91610000')
  28.     INTEGER FRONTWINDOW
  29.     PARAMETER (FRONTWINDOW=Z'92480000')
  30.     
  31.       integer*2 ItemHit
  32.     
  33.     logical done
  34.  
  35.     filter_1 = ctlprc ( my_filter , 16 )    !Four long words                                 !arguments
  36.     call xfilt ( filter_1 , my_filter_ptr )
  37.     
  38.     done = .false.
  39.     
  40.     call toolbx (TEINIT)
  41.     call toolbx ( INITDIALOGS , 0 )
  42.  
  43.     call toolbx ( HIDEWINDOW , toolbx ( FRONTWINDOW ) )
  44.  
  45.     dialog_ptr = toolbx ( GETNEWDIALOG , 100 , 0 , -1 )
  46.  
  47.     word ( dialog_ptr + aDefItem ) = 0
  48.     
  49.     do while ( .not. done )
  50.  
  51.       call  toolbx ( MODALDIALOG , my_filter_ptr , ItemHit )
  52.       select case ( ItemHit )
  53.       
  54.         case ( top_field )
  55.           result = getdit ( top_field , dialog_ptr )
  56.           call setdit ( result , result_field , dialog_ptr )
  57.           
  58.  
  59.         case ( bottom_field )
  60.           result = getdit ( bottom_field , dialog_ptr )
  61.           result = result * 10
  62.           call setdit ( result , result_field , dialog_ptr )
  63.           
  64.         case ( end_dialog )
  65.           call toolbx ( DISPOSDIALOG , dialog_ptr )
  66.           done = .true.
  67.  
  68.         case default
  69.           continue
  70.  
  71.       end select
  72.     repeat
  73.  
  74.     end
  75.  
  76.     subroutine my_filter ( argptr )
  77.  
  78.     implicit none            ! Declare all variables.
  79.  
  80.     integer toolbx
  81.     integer Dg_ptr , ItemHit_ptr , ev_ptr , argptr , result_ptr
  82.     
  83.     integer i , char_code
  84.     integer*2 ItemHit
  85.     logical handle_event
  86.  
  87.     integer*1 eventrecord(16)    ! overlying structure
  88.     
  89.     integer*2 what        ! type of event:
  90.     integer*4 when        ! time of event in 60ths of seconds
  91.     integer*2 where(2)    ! mouse location in global coordinates
  92.     integer*2 modifiers    ! state of mouse button and modifier keys:
  93.     integer*4 message        ! extra event information:
  94.  
  95.          equivalence ( eventrecord(1)  , what )
  96.         equivalence ( eventrecord(3)  , message )
  97.         equivalence ( eventrecord(7)  , when )
  98.         equivalence ( eventrecord(11) , where(1) )
  99.         equivalence ( eventrecord(15) , modifiers )
  100.  
  101.     integer aDefItem , editField
  102.     parameter ( aDefItem = Z'A8', editField = Z'A4' )
  103.  
  104.     result_ptr = long ( argptr + 12 )
  105.     Dg_ptr = long ( argptr + 8 )
  106.     ev_ptr = long ( argptr + 4)
  107.     ItemHit_ptr = long ( argptr )
  108.  
  109.     do ( i = 1 , 16 )
  110.       eventrecord (i)  = byte ( ev_ptr + i - 1 )
  111.     repeat
  112.  
  113.         if ( what .eq. 3 ) then        !key down
  114.  
  115. C  If user hits return or enter key, check the default item number. If 
  116. C  it is zero, then return with ItemHit as the active edit text field. 
  117. C  If the default item is nonzero, return it as the ItemHit.
  118.  
  119.           char_code = message .and. Z'000000FF'
  120.           if ( char_code .eq. 13 .or. char_code .eq. 3 ) then
  121.             if ( word ( Dg_ptr + aDefItem ) .eq. 0 ) then
  122.               ItemHit = word ( Dg_ptr + editField ) + 1
  123.               handle_event = .false.
  124.             else
  125.               ItemHit = word ( Dg_ptr + aDefItem )
  126.               handle_event = .false.
  127.             end if
  128.           else
  129.             handle_event = .true.
  130.           end if
  131.         else
  132.       handle_event = .true.
  133.     end if
  134.  
  135.     if ( handle_event ) then
  136.           word ( result_ptr ) = z'0'
  137.         else
  138.           word ( result_ptr ) = z'FFFF'
  139.           word ( ItemHit_ptr ) = ItemHit
  140.         end if
  141.  
  142.     return
  143.     end
  144.  
  145.     integer function get_dit ( item_num , dg_ptr )
  146.  
  147.     implicit none
  148.     integer toolbx , item_num , dg_ptr ,itemhandle
  149.     integer itemp , ktemp
  150.     character*256 temp , dgtext
  151.     integer*2 ItemType , box (4)
  152.  
  153.     integer GETDITEM , GETITEXT
  154.     parameter (GETDITEM=Z'98D11DB0', GETITEXT=Z'99016000' )
  155.  
  156.     call toolbx ( GETDITEM , dg_ptr , item_num ,
  157.      *           ItemType , itemhandle , box )
  158.     call toolbx ( GETITEXT , itemhandle , dgtext )
  159.     itemp = ichar ( dgtext (1:1) ) + 1
  160.     ktemp = 0
  161.     if ( itemp .gt. 1 ) then
  162.       temp = dgtext ( 2 : itemp )
  163.       read ( temp , * , err = 100 ) ktemp
  164.     end if
  165.     get_dit = ktemp
  166.     return
  167. 100    get_dit = 0
  168.  
  169.     return
  170.     end
  171.  
  172.     subroutine set_dit ( value , item_num , dg_ptr )
  173.  
  174.     implicit none
  175.     integer toolbx , item_num , dg_ptr , ItemType , itemhandle
  176.     integer value
  177.     integer*2 box (4)
  178.     character*256 dgtext
  179.  
  180.     integer GETDITEM , SETITEXT
  181.     parameter (GETDITEM=Z'98D11DB0', SETITEXT=Z'98F16000' )
  182.  
  183.     write ( dgtext , * ) value
  184.     dgtext (1:1) = char ( len ( trim ( dgtext) ) - 1 )
  185.     call toolbx ( GETDITEM , dg_ptr , item_num ,
  186.      *           ItemType , itemhandle , box )
  187.     call toolbx ( SETITEXT , itemhandle , dgtext )
  188.  
  189.     return
  190.     end
  191.  
  192.